VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsPentago"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function CreatePen Lib "gdi32.dll" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function PolyPolyline Lib "gdi32.dll" (ByVal hdc As Long, ByRef lppt As POINTAPI, ByRef lpdwPolyPoints As Long, ByVal cCount As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function GetStockObject Lib "gdi32.dll" (ByVal nIndex As Long) As Long
Private Declare Function Ellipse Lib "gdi32.dll" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetSysColor Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Const NULL_BRUSH As Long = 5
Private Const WHITE_BRUSH As Long = 0
Private Const BLACK_BRUSH As Long = 4

Private Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)

Implements IGameState

Private Type typePentagoState
 nPlayerJustMoved As Byte
 nResult As Byte 'always precomputed, 0=not finished, 1=draw, 2=win w.r.t playerJustMoved, 3=lose, i.e. the real one Xor 3
 nMoveCount As Byte
 nReserved As Byte
 b(35) As Byte
End Type

Private m_t As typePentagoState
Private m_nMoves As Long 'bit 0-7: pos (0-35), bit 8-9: rotation pos, bit 10: rotation direction (0=cw, 1=ccw)
'&H4000=position selected (draw rotation arrows), &H10000=rotation selected

Private m_nAnimation As Long 'bit 0-7: animation time (>0), bit 8-10: same as above

Friend Sub CloneFrom(ByRef t As typePentagoState)
m_t = t
End Sub

Private Sub IGameState_ClearUserMoves()
m_nMoves = -1
End Sub

Private Function IGameState_Clone() As IGameState
Dim obj As New clsPentago
obj.CloneFrom m_t
Set IGameState_Clone = obj
End Function

Private Function IGameState_DoMove(ByVal lpData As Long, ByVal nSize As Long) As Boolean
Dim nMove As Long
Dim idx As Long
Dim i As Long, j As Long, k As Long
Dim ii As Long
Dim n As Long
'///
If lpData = 0 Or nSize < 2 Then Exit Function
CopyMemory nMove, ByVal lpData, 2
'///
i = nMove And &HFF&
If m_t.b(i) <> 0 Then Exit Function
'///
IGameState_DoMove = True
'///
m_t.nPlayerJustMoved = (m_t.nPlayerJustMoved And 1&) + 1
m_t.b(i) = m_t.nPlayerJustMoved
m_t.nMoveCount = m_t.nMoveCount + 1
'///check winning condition
j = i \ 6&
k = j * 6&
i = i - k
'horizontal
If m_t.b(k + 1) = m_t.nPlayerJustMoved Then
 If m_t.b(k + 2) = m_t.nPlayerJustMoved Then
  If m_t.b(k + 3) = m_t.nPlayerJustMoved Then
   If m_t.b(k + 4) = m_t.nPlayerJustMoved Then
    If m_t.b(k) = m_t.nPlayerJustMoved Or m_t.b(k + 5) = m_t.nPlayerJustMoved Then
     m_t.nResult = 2
     Exit Function
    End If
   End If
  End If
 End If
End If
'vertical
If m_t.b(i + 6) = m_t.nPlayerJustMoved Then
 If m_t.b(i + 12) = m_t.nPlayerJustMoved Then
  If m_t.b(i + 18) = m_t.nPlayerJustMoved Then
   If m_t.b(i + 24) = m_t.nPlayerJustMoved Then
    If m_t.b(i) = m_t.nPlayerJustMoved Or m_t.b(i + 30) = m_t.nPlayerJustMoved Then
     m_t.nResult = 2
     Exit Function
    End If
   End If
  End If
 End If
End If
'diagonal
k = i + k
If i - j >= -1 And i - j <= 1 Then
 n = 0
 idx = k
 ii = i
 If ii > j Then ii = j
 Do While ii > 0
  idx = idx - 7
  If m_t.b(idx) <> m_t.nPlayerJustMoved Then Exit Do
  ii = ii - 1
  n = n + 1
 Loop
 idx = k
 ii = i
 If ii < j Then ii = j
 Do While ii < 5
  idx = idx + 7
  If m_t.b(idx) <> m_t.nPlayerJustMoved Then Exit Do
  ii = ii + 1
  n = n + 1
 Loop
 If n >= 4 Then
  m_t.nResult = 2
  Exit Function
 End If
End If
If i + j >= 4 And i + j <= 6 Then
 n = 0
 idx = k
 ii = 5 - i
 If ii > j Then ii = j
 Do While ii > 0
  idx = idx - 5
  If m_t.b(idx) <> m_t.nPlayerJustMoved Then Exit Do
  ii = ii - 1
  n = n + 1
 Loop
 idx = k
 ii = 5 - j
 If ii > i Then ii = i
 Do While ii > 0
  idx = idx + 5
  If m_t.b(idx) <> m_t.nPlayerJustMoved Then Exit Do
  ii = ii - 1
  n = n + 1
 Loop
 If n >= 4 Then
  m_t.nResult = 2
  Exit Function
 End If
End If
'///rotate board
m_nAnimation = (nMove And &H700&) Or 9&
idx = 7 + (((nMove And &H100&) <> 0) And 3&) + (((nMove And &H200&) <> 0) And 18&)
If nMove And &H400& Then 'rotate ccw
 i = m_t.b(idx + 1)
 m_t.b(idx + 1) = m_t.b(idx + 6)
 m_t.b(idx + 6) = m_t.b(idx - 1)
 m_t.b(idx - 1) = m_t.b(idx - 6)
 m_t.b(idx - 6) = i
 i = m_t.b(idx + 7)
 m_t.b(idx + 7) = m_t.b(idx + 5)
 m_t.b(idx + 5) = m_t.b(idx - 7)
 m_t.b(idx - 7) = m_t.b(idx - 5)
 m_t.b(idx - 5) = i
Else 'rotate cw
 i = m_t.b(idx + 1)
 m_t.b(idx + 1) = m_t.b(idx - 6)
 m_t.b(idx - 6) = m_t.b(idx - 1)
 m_t.b(idx - 1) = m_t.b(idx + 6)
 m_t.b(idx + 6) = i
 i = m_t.b(idx + 7)
 m_t.b(idx + 7) = m_t.b(idx - 5)
 m_t.b(idx - 5) = m_t.b(idx - 7)
 m_t.b(idx - 7) = m_t.b(idx + 5)
 m_t.b(idx + 5) = i
End If
'///check winning condition again
n = 0
'horizontal
k = (((nMove And &H200&) <> 0) And 18&)
For i = 0 To 2
 j = m_t.b(k + 1)
 If j > 0 Then
  If m_t.b(k + 2) = j Then
   If m_t.b(k + 3) = j Then
    If m_t.b(k + 4) = j Then
     If m_t.b(k) = j Or m_t.b(k + 5) = j Then
      n = n Or j
      If n = 3 Then
       m_t.nResult = 1
       Exit Function
      End If
     End If
    End If
   End If
  End If
 End If
 k = k + 6
Next i
'vertical
k = (((nMove And &H100&) <> 0) And 3&)
For i = 0 To 2
 j = m_t.b(k + 6)
 If j > 0 Then
  If m_t.b(k + 12) = j Then
   If m_t.b(k + 18) = j Then
    If m_t.b(k + 24) = j Then
     If m_t.b(k) = j Or m_t.b(k + 30) = j Then
      n = n Or j
      If n = 3 Then
       m_t.nResult = 1
       Exit Function
      End If
     End If
    End If
   End If
  End If
 End If
 k = k + 1
Next i
'diagonal
If (nMove And &H300&) <> &H200& Then
 j = m_t.b(1)
 If j > 0 Then
  If m_t.b(8) = j Then
   If m_t.b(15) = j Then
    If m_t.b(22) = j Then
     If m_t.b(29) = j Then
      n = n Or j
      If n = 3 Then
       m_t.nResult = 1
       Exit Function
      End If
     End If
    End If
   End If
  End If
 End If
End If
If (nMove And &H300&) <> &H100& Then
 j = m_t.b(6)
 If j > 0 Then
  If m_t.b(13) = j Then
   If m_t.b(20) = j Then
    If m_t.b(27) = j Then
     If m_t.b(34) = j Then
      n = n Or j
      If n = 3 Then
       m_t.nResult = 1
       Exit Function
      End If
     End If
    End If
   End If
  End If
 End If
End If
j = m_t.b(7)
If j > 0 Then
 If m_t.b(14) = j Then
  If m_t.b(21) = j Then
   If m_t.b(28) = j Then
    If m_t.b(0) = j Or m_t.b(35) = j Then
     n = n Or j
     If n = 3 Then
      m_t.nResult = 1
      Exit Function
     End If
    End If
   End If
  End If
 End If
End If
If (nMove And &H300&) <> &H300& Then
 j = m_t.b(4)
 If j > 0 Then
  If m_t.b(9) = j Then
   If m_t.b(14) = j Then
    If m_t.b(19) = j Then
     If m_t.b(24) = j Then
      n = n Or j
      If n = 3 Then
       m_t.nResult = 1
       Exit Function
      End If
     End If
    End If
   End If
  End If
 End If
End If
If (nMove And &H300&) <> 0& Then
 j = m_t.b(11)
 If j > 0 Then
  If m_t.b(16) = j Then
   If m_t.b(21) = j Then
    If m_t.b(26) = j Then
     If m_t.b(31) = j Then
      n = n Or j
      If n = 3 Then
       m_t.nResult = 1
       Exit Function
      End If
     End If
    End If
   End If
  End If
 End If
End If
j = m_t.b(10)
If j > 0 Then
 If m_t.b(15) = j Then
  If m_t.b(20) = j Then
   If m_t.b(25) = j Then
    If m_t.b(5) = j Or m_t.b(30) = j Then
     n = n Or j
     If n = 3 Then
      m_t.nResult = 1
      Exit Function
     End If
    End If
   End If
  End If
 End If
End If
If n > 0 Then
 m_t.nResult = 2& Xor ((n Xor m_t.nPlayerJustMoved) And 1&)
 Exit Function
End If
'///check if the board is full
If m_t.nMoveCount >= 36 Then m_t.nResult = 1
End Function

Private Function IGameState_Draw(ByVal bm As cDIBSection, ByVal nWidth As Long, ByVal nHeight As Long) As Boolean
Dim w As Long
Dim hbr(3) As Long, hpn(2) As Long
Dim r As RECT
Dim ii As Long, jj As Long
Dim i As Long, j As Long
Dim p(24) As POINTAPI, m2(7) As Long
Dim sss As Single, ccc As Single
'///background
hbr(0) = CreateSolidBrush(GetSysColor(vbButtonFace And &HFF&))
r.Right = nWidth
r.Bottom = nHeight
FillRect bm.hdc, r, hbr(0)
DeleteObject hbr(0)
'///
If nWidth > nHeight Then nWidth = nHeight
w = nWidth \ 16
'///update animation
If m_nAnimation > 0 Then
 m_nAnimation = m_nAnimation - 1
 If (m_nAnimation And &HFF&) = 0 Then m_nAnimation = 0 _
 Else IGameState_Draw = True
End If
'///
hbr(0) = SelectObject(bm.hdc, GetStockObject(NULL_BRUSH))
hbr(1) = GetStockObject(BLACK_BRUSH)
hbr(2) = GetStockObject(WHITE_BRUSH)
hbr(3) = CreateSolidBrush(&H808080)
hpn(1) = CreatePen(0, 2, vbBlack)
hpn(2) = CreatePen(2, 1, vbBlack)
hpn(0) = SelectObject(bm.hdc, hpn(1))
'///draw chessboard
For i = 0 To 7
 m2(i) = 2
Next i
For jj = 0 To 1
 For ii = 0 To 1
  'calculate coordinate of points
  For i = 0 To 3
   p(i * 2).x = (i * 2 - 3) * w
   p(i * 2).y = -3 * w
   p(i * 2 + 1).x = p(i * 2).x
   p(i * 2 + 1).y = 3 * w
   p(i * 2 + 8).x = p(i * 2).y
   p(i * 2 + 8).y = p(i * 2).x
   p(i * 2 + 9).x = p(i * 2 + 1).y
   p(i * 2 + 9).y = p(i * 2 + 1).x
  Next i
  For j = 0 To 2
   For i = 0 To 2
    p(16 + j * 3 + i).x = (i * 2 - 2) * w
    p(16 + j * 3 + i).y = (j * 2 - 2) * w
   Next i
  Next j
  'check if we need to rotation it
  i = (m_nAnimation And &HFF&)
  If i > 0 And ((jj * &H200&) Or (ii * &H100&)) = (m_nAnimation And &H300&) Then
   If (m_nAnimation And &H400&) = 0 Then i = -i
   sss = 0.1963495! * i
   ccc = Cos(sss)
   sss = Sin(sss)
   For i = 0 To 24
    j = p(i).x
    p(i).x = j * ccc - p(i).y * sss
    p(i).y = j * sss + p(i).y * ccc
   Next i
  End If
  'draw grid and marbles
  For i = 0 To 24
   p(i).x = p(i).x + (5 + ii * 6) * w
   p(i).y = p(i).y + (5 + jj * 6) * w
  Next i
  PolyPolyline bm.hdc, p(0), m2(0), 8
  For j = 0 To 2
   For i = 0 To 2
    r.Top = (jj * 3 + j) * 6 + (ii * 3 + i)
    r.Right = 16 + j * 3 + i
    r.Bottom = p(r.Right).y
    r.Right = p(r.Right).x
    '///
    r.Left = m_t.b(r.Top)
    If r.Left = 0 Then
     If (m_nMoves >= 0 And (m_nMoves And &H4000&) <> 0) And (m_nMoves And &HFF&) = r.Top Then
      'draw candidate
      SelectObject bm.hdc, hpn(2)
      SelectObject bm.hdc, hbr(3 - (m_t.nPlayerJustMoved And 1&))
      Ellipse bm.hdc, r.Right - w + 4, r.Bottom - w + 4, r.Right + w - 4, r.Bottom + w - 4
      SelectObject bm.hdc, hpn(1)
     End If
    Else
     'draw existing
     SelectObject bm.hdc, hbr(((r.Left - 1) And 1&) + 1)
     Ellipse bm.hdc, r.Right - w + 4, r.Bottom - w + 4, r.Right + w - 4, r.Bottom + w - 4
    End If
   Next i
  Next j
 Next ii
Next jj
'///draw arrows
If m_nMoves >= 0 And (m_nMoves And &H4000&) <> 0 Then
 p(0).x = w * 2
 p(0).y = w
 p(1).x = w * 4
 p(1).y = w
 p(2).x = w * 3
 p(2).y = w \ 2
 p(3).x = p(1).x
 p(3).y = w
 p(4).x = p(2).x
 p(4).y = w + p(2).y
 For i = 0 To 4
  p(i + 5).x = p(i).y
  p(i + 5).y = p(i).x
 Next i
 w = w * 16&
 For i = 0 To 9
  p(i + 10).x = w - p(i).x
  p(i + 10).y = p(i).y
 Next i
 m2(1) = 3
 m2(3) = 3
 m2(5) = 3
 m2(7) = 3
 PolyPolyline bm.hdc, p(0), m2(0), 8
 For i = 0 To 19
  p(i).y = w - p(i).y
 Next i
 PolyPolyline bm.hdc, p(0), m2(0), 8
End If
'///over
SelectObject bm.hdc, hbr(0)
SelectObject bm.hdc, hpn(0)
DeleteObject hbr(3)
DeleteObject hpn(1)
DeleteObject hpn(2)
End Function

Private Function IGameState_FilterByRandomFactor(ByVal lpData As Long, ByVal nSize As Long) As Boolean
IGameState_FilterByRandomFactor = True
End Function

'FIXME: maybe something wrong here
Private Function IGameState_GetMoves(bData() As Byte, nSize As Long, ByVal bRespectRandomFactor As Boolean) As Long
Dim n1 As Long
Dim b2(11) As Byte, n2 As Long
Dim i As Long, j As Long, k As Long, idx As Long
'///
nSize = 2
'///check empty blocks
For k = 0 To 35
 If m_t.b(k) = 0 Then n1 = n1 + 1
Next k
If n1 = 36 Then 'it's completely empty
 ReDim bData(17)
 For j = 0 To 2
  For i = 0 To 2
   bData(j * 6 + i * 2) = j * 6 + i + 3
  Next i
 Next j
 IGameState_GetMoves = 9
 Exit Function
End If
If n1 = 0 Then Exit Function
'///check symmetry
For j = 0 To 1
 For i = 0 To 1
  idx = j * 18& + i * 3&
  k = m_t.b(idx)
  If m_t.b(idx + 2) = k Then
   If m_t.b(idx + 12) = k Then
    If m_t.b(idx + 14) = k Then
     k = m_t.b(idx + 1)
     If m_t.b(idx + 6) = k Then
      If m_t.b(idx + 8) = k Then
       If m_t.b(idx + 13) = k Then
        b2((j * 2&) Or i Or 8&) = 1
       End If
      End If
     End If
    End If
   End If
  End If
 Next i
Next j
j = 0
For i = 0 To 3
 If b2(i Or 8&) Then
  If j = 0 Then
   b2(n2) = i
   n2 = n2 + 1
   j = 1
  End If
 Else
  b2(n2) = i
  b2(n2 + 1) = i Or 4&
  n2 = n2 + 2
 End If
Next i
'///create
n1 = n1 * n2
ReDim bData(n1 * 2& - 1)
i = 0
For k = 0 To 35
 If m_t.b(k) = 0 Then
  For j = 0 To n2 - 1
   bData(i) = k
   bData(i + 1) = b2(j)
   i = i + 2
  Next j
 End If
Next k
Debug.Assert n1 * 2 = i
'///over
IGameState_GetMoves = n1
End Function

'TODO: prefer winning moves
Private Function IGameState_GetRandomMoves(bData() As Byte, nSize As Long, ByVal bReversed As Boolean) As Boolean
Dim b(35) As Byte, n1 As Long
Dim k As Long
'///
For k = 0 To 35
 If m_t.b(k) = 0 Then
  b(n1) = k
  n1 = n1 + 1
 End If
Next k
If n1 <= 0 Then Exit Function
'///
nSize = 2
ReDim bData(1)
bData(0) = b(Int(n1 * Rnd))
bData(1) = Int(8 * Rnd)
IGameState_GetRandomMoves = True
End Function

Private Function IGameState_GetResult(ByVal nPlayerJustMoved As Long) As Long
Dim i As Long
i = m_t.nResult
IGameState_GetResult = i Xor 3 Xor (i >= 2 And (nPlayerJustMoved Xor m_t.nPlayerJustMoved) And 1&)
End Function

Private Function IGameState_GetUserMoves(bData() As Byte, nSize As Long) As Boolean
If m_nMoves < &H10000 Then Exit Function
ReDim bData(1)
bData(0) = m_nMoves And &HFF&
bData(1) = (m_nMoves And &HF00&) \ &H100&
nSize = 2
IGameState_GetUserMoves = True
End Function

Private Function IGameState_OnMouseDown(ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal Button As MouseButtonConstants, ByVal Shift As ShiftConstants) As Long
'///
If nWidth > nHeight Then nWidth = nHeight
nWidth = nWidth \ 16
If nWidth <= 0 Then Exit Function
nWidth = nWidth * 2
'///
If x < 0 Or y < 0 Then Exit Function
x = x \ nWidth
y = y \ nWidth
If x >= 8 Or y >= 8 Then Exit Function
'///check clicked the board
If x >= 1 And y >= 1 And x <= 6 And y <= 6 Then
 x = (y - 1) * 6 + x - 1
 If m_t.b(x) Then
  Beep
 Else
  m_nMoves = x Or &H4000&
  IGameState_OnMouseDown = 1
 End If
 Exit Function
End If
'///check clicked the arrow
If (x = 1 Or x = 6 Or y = 1 Or y = 6) And m_nMoves >= 0 And (m_nMoves And &H4000&) <> 0 Then
 m_nMoves = m_nMoves Or ((x >= 4) And &H100&) Or ((y >= 4) And &H200&) Or _
 (((y And 1&) <> 0 Xor x >= 4) And &H400&) Or &H10000
 IGameState_OnMouseDown = 2
Else
 Beep
End If
End Function

Private Function IGameState_OnMouseMove(ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal Button As MouseButtonConstants, ByVal Shift As ShiftConstants) As Long
'do nothing
End Function

Private Function IGameState_OnMouseUp(ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal Button As MouseButtonConstants, ByVal Shift As ShiftConstants) As Long
'do nothing
End Function

Private Property Get IGameState_PlayerJustMoved() As Long
IGameState_PlayerJustMoved = m_t.nPlayerJustMoved
End Property
